home *** CD-ROM | disk | FTP | other *** search
/ Monster Media 1996 #15 / Monster Media Number 15 (Monster Media)(July 1996).ISO / arc / fact127.zip / FACT.PAS < prev    next >
Pascal/Delphi Source File  |  1996-05-23  |  32KB  |  1,083 lines
  1. PROGRAM Freeware_Archive_Conversion_Tool;
  2. (*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  3. | Program:    FACT (Freeware Archive Conversion Tool)
  4. | Version:    1.27 - May 23, 1996
  5. | Author:     David Daniel Anderson
  6. | Copyright applies, but feel free to use "fair-use" size portions of code.
  7. -----------------------------------------------------------------------------*)
  8. {$M 20480,0,655360}
  9. {$N-,E- no math support needed}
  10. {$X- function calls may not be discarded}
  11. {$I- disable I/O checking (trap errors by checking IOResult)}
  12.  
  13. USES DOS, HeapMan;
  14. TYPE
  15.   STR128 = STRING[128];
  16.   FList = ^FNode;
  17.   FNode = RECORD
  18.             ArcFName: STRING[12];  { File names of archives to process. }
  19.             DelWhenDone: BOOLEAN;  { Does FACT delete archive when done? }
  20.             Next: FList;
  21.           END;
  22.   ArcCommands = RECORD
  23.                   ReCompress: STR128;  { Command line for each ReCompressor. }
  24.                   DeCompress: STR128;  { Command line for each DeCompressor. }
  25.                   DirsCompressed: BOOLEAN;  { Does compressor compress dirs? }
  26.                 END;
  27. VAR
  28.   SavedExitProc: POINTER;  { CustomExit proc inserted into normal exit. }
  29.   ComSpec: PATHSTR;        { Used to execute commands. }
  30.   WATCH,                   { If TRUE, ReadLn executed after info messages. }
  31.   DelOriginal,             { If TRUE, the original archive is deleted. }
  32.   QUIET,                   { If TRUE, most compressor output is suppressed. }
  33.   ONE: BOOLEAN;            { If TRUE, convert only the primary archive. }
  34.   RecursionLevel: BYTE;    { How deep the recursion is, affects ZIP archives. }
  35.   NewExt: EXTSTR;          { New extension -- for recompressed archives. }
  36.   ArcString: STRING;       { String of extensions of validated compressors. }
  37.   ArcArray: Array[1..244] of ArcCommands;  { Commands for archive types. }
  38.   FileList: FList;         { Singly linked list of archives to process. }
  39.  
  40. FUNCTION getFileName (fn: STR128): NAMESTR; FORWARD;
  41. PROCEDURE NewLine; FORWARD;
  42. PROCEDURE WriteStr (CONST s: STRING); FORWARD;
  43. FUNCTION WordToHex (i: WORD): EXTSTR; FORWARD;
  44.  
  45. PROCEDURE CustomExit; FAR; {---- Always exit through here ----}
  46. CONST
  47.   NL = #13#10;
  48. VAR
  49.   message: STRING [79];
  50. BEGIN
  51.   ExitProc := SavedExitProc;
  52.   IF (ExitCode > 0) THEN BEGIN
  53.     NewLine;
  54.     WriteStr ('FACT v1.27 - DOS utility: Freeware Archive Conversion Tool.');
  55.     WriteStr ('May 23, 1996. Copyright (c) 1996 by David Daniel Anderson - Reign Ware.'+NL);
  56.     WriteStr ('   Usage :  FACT archives .NewExt [-d] [-q] [-w] [-1]'+NL);
  57.     WriteStr ('   Where :  "archives" is specification of the archives to convert.');
  58.     WriteStr ('         :  ".NewExt" is the extension(s) you wish to convert them to.');
  59.     WriteStr ('         :  "-d"=del - forces the original archive to be deleted.  [Optional]');
  60.     WriteStr ('         :  "-q"=quiet - hides most of the compressors'' messages.  [Optional]');
  61.     WriteStr ('         :  "-w"=watch - causes FACT to pause after every action.  [Optional]');
  62.     WriteStr ('         :  "-1"=1 level - only recompress the _primary_ archive.  [Optional]'+NL);
  63.     WriteStr ('Examples :  FACT c:\dls\*.zip .lzh');
  64.     WriteStr ('         :  FACT somefile.arc .arj .zip .uc2 -d');
  65.     WriteStr ('         :  FACT anyfiles.* .rar -d -q'+NL);
  66.     WriteStr ('   Hints :  DOS wildcards may be used when specifying the archives.');
  67.     WriteStr ('         :  Multiple ".NewExt" new extensions may be specified at one time.'+NL);
  68.   END;
  69.   IF ErrorAddr <> NIL THEN
  70.   BEGIN
  71.     WriteStr ('An unanticipated error occurred, please contact DDA with the following data:');
  72.     WriteLn ('Address = ', WordToHex (Seg (ErrorAddr^)), ':', WordToHex (Ofs (ErrorAddr^)));
  73.     WriteLn ('Code    = ', ExitCode);
  74.     ErrorAddr := NIL;
  75.   END
  76.   ELSE
  77.     IF (ExitCode IN [1..254]) THEN BEGIN
  78.       CASE ExitCode OF
  79.         1 : message := 'No '+getFileName (ParamStr (0))+'.INI file found.  It must be in same dir as '+ParamStr(0)+'.';
  80.         2 : message := 'No defined archives found matching "'+ParamStr(1)+'"!';
  81.         3 : message := 'None of the ".NewExt" compressors were validated.';
  82.         4 : message := 'User aborted while in "watch" mode.  Working files may remain!';
  83.         6 : message := '"COMSPEC" not set!  Type "COMSPEC=c:\dos\command.com" (or similar) to set it.';
  84.         7 : message := 'File handling error.  There are likely files and directories to clean up now.';
  85.         ELSE  message := 'Unknown error.';
  86.       END;
  87.       WriteLn ('Error encountered (#', ExitCode, '):'); WriteStr (message);
  88.     END;
  89. END;
  90.  
  91. PROCEDURE CheckIO; { Check IOResult, exit on error. }
  92. BEGIN
  93.   IF IOResult <> 0 THEN Halt (7);
  94. END;
  95.  
  96. PROCEDURE NewLine;
  97. BEGIN
  98.   WriteLn;
  99. END;
  100.  
  101. PROCEDURE WriteStr (CONST s: STRING);
  102. BEGIN
  103.   WriteLn (s);
  104. END;
  105.  
  106. FUNCTION WordToHex (i: WORD): EXTSTR; {Convert a WORD variable to STRING[4]}
  107. CONST
  108.   HexLetters : ARRAY [0..15] OF CHAR = '0123456789ABCDEF';
  109. BEGIN
  110.   WordToHex := Concat (HexLetters [Hi (i) SHR 4], HexLetters [Hi (i) AND 15],
  111.                        HexLetters [Lo (i) SHR 4], HexLetters [Lo (i) AND 15]);
  112. END;
  113.  
  114. PROCEDURE ClrScr; ASSEMBLER;
  115. (* Routine from SWAG *)
  116. ASM
  117.   MOV AH, 0Fh
  118.   Int 10h
  119.   MOV AH, 0
  120.   Int 10h
  121. END;
  122.  
  123. PROCEDURE Delay (ms : WORD); ASSEMBLER;
  124. ASM {machine independent Delay Function}
  125.   mov AX, 1000;
  126.   mul ms;
  127.   mov CX, DX;
  128.   mov DX, AX;
  129.   mov AH, $86;
  130.   Int $15;
  131. END;
  132.  
  133. PROCEDURE Pause; { Pauses for WATCH mode. }
  134.   FUNCTION ReadKey: CHAR;
  135.   VAR
  136.     r: REGISTERS;
  137.   BEGIN
  138.     r. AX := $0700;
  139.     Intr ($21, r);
  140.     ReadKey := Chr (r. AL);
  141.   END;
  142.  
  143. VAR
  144.   k: CHAR;
  145. BEGIN
  146.   NewLine;
  147.   WriteStr ('Watch mode: press "N" to stop watching, or "A" to abort FACT.');
  148.   Write ('Otherwise, press any other normal key to continue ... ');
  149.   k := ReadKey;
  150.   Write (k);
  151.   IF k IN ['n', 'N'] THEN WATCH := FALSE;
  152.   IF k IN ['a', 'A'] THEN Halt (4);
  153.   NewLine;
  154.   NewLine;
  155. END;
  156.  
  157. FUNCTION CommandProg (fn : STR128): STR128; {Separate prog name from switches.}
  158. BEGIN
  159.   IF (Pos (#32, fn) > 0)
  160.     THEN CommandProg := Copy (fn, 1, (Pos (#32, fn) - 1))
  161.     ELSE CommandProg := fn;
  162. END;
  163.  
  164. FUNCTION CommandTail (fn : STR128): STR128; {Separate prog switches from name.}
  165. BEGIN
  166.   IF (Pos (#32, fn) > 0)
  167.     THEN CommandTail := Copy (fn, Pos (#32, fn), Length (fn))
  168.     ELSE CommandTail := '';
  169. END;
  170.  
  171. FUNCTION RPad (bstr: STRING; len: BYTE): STRING;
  172. BEGIN
  173.   WHILE (Length (bstr) < len) DO
  174.     bstr := bstr + #32;
  175.   RPad := bstr;
  176. END;
  177.  
  178. FUNCTION RTrim (InStr: STRING): STRING;
  179. BEGIN
  180.   WHILE (Length (InStr) > 0) AND (InStr [Length (InStr)] IN [#0, #9, #32]) DO
  181.     Dec (InStr [0]);
  182.   RTrim := InStr;
  183. END;
  184.  
  185. FUNCTION LTrim (InStr: STRING): STRING;
  186. BEGIN
  187.   WHILE (Length (InStr) > 0) AND (InStr [1] IN [#0, #9, #32]) DO
  188.     Delete (InStr, 1, 1);
  189.   LTrim := InStr;
  190. END;
  191.  
  192. FUNCTION Trim (InStr: STRING): STRING;
  193. BEGIN
  194.   Trim := RTrim (LTrim (InStr));
  195. END;
  196.  
  197. FUNCTION Upper (lstr: STRING): STRING;
  198.   PROCEDURE UpFast (VAR Str: STRING);  {** from SWAG **}
  199.   INLINE($8C/$DA/$5E/$1F/$FC/$AC/$30/$E4/$89/$C1/$E3/$12/$BB/Ord('a')/Ord('z')/
  200.          $AC/$38/$D8/$72/$08/$38/$F8/$77/$04/$80/$6C/$FF/$20/$E2/$F1/$8E/$DA);
  201. BEGIN
  202.   UpFast (lstr);
  203.   Upper := lstr;
  204. END;
  205.  
  206. FUNCTION IsSwitch (sSwitch: STRING): BOOLEAN;
  207. VAR
  208.   Return : BOOLEAN;
  209.   Param : STRING;
  210.   pc : BYTE;
  211. BEGIN
  212.   Return := FALSE;
  213.   IF (ParamCount > 2) THEN
  214.   BEGIN
  215.     sSwitch := Upper (sSwitch);
  216.     FOR pc := 3 to ParamCount DO
  217.     IF (Return = FALSE) THEN
  218.     BEGIN
  219.       Param := Upper (ParamStr (pc));
  220.       IF (Pos ('/'+sSwitch, Param) > 0) OR (Pos ('-'+sSwitch, Param) > 0)
  221.         THEN Return := TRUE;
  222.     END;
  223.   END;
  224.   IsSwitch := Return;
  225. END;
  226.  
  227. FUNCTION getFileExt (fn: STR128): EXTSTR;
  228. VAR
  229.   p: BYTE;
  230. BEGIN
  231.   p := (Pos ('.', fn));
  232.   IF (p > 0)
  233.     THEN getFileExt := Copy (fn, p, 1 + Length (fn) - p)
  234.     ELSE getFileExt := '';
  235. END;
  236.  
  237. FUNCTION getFileName (fn: STR128): NAMESTR;
  238. VAR
  239.   p: BYTE;
  240.   b: BOOLEAN;
  241. BEGIN
  242.   b := TRUE;
  243.   WHILE b DO
  244.   BEGIN
  245.     p := Pos ('\', fn);
  246.     IF (p > 1)
  247.       THEN fn := Copy (fn, p+1, Length (fn) - p)
  248.       ELSE b := FALSE;
  249.   END;
  250.   IF (Pos ('.', fn) > 0)
  251.     THEN getFileName := Copy (fn, 1, (Pos ('.', fn) - 1))
  252.     ELSE getFileName := fn;
  253. END;
  254.  
  255. FUNCTION IsDir (CONST FileName: PATHSTR): BOOLEAN;
  256. VAR
  257.   Attr  : WORD;
  258.   cFile : FILE;
  259. BEGIN
  260.   Assign (cFile, FileName);
  261.   GetFAttr (cFile, Attr);
  262.   IF (DosError = 0) AND ((Attr AND Directory) = Directory)
  263.     THEN IsDir := TRUE
  264.     ELSE IsDir := FALSE;
  265. END;
  266.  
  267. FUNCTION IsFile (CONST FileName: PATHSTR): BOOLEAN;
  268. VAR
  269.   Attr  : WORD;
  270.   cFile : FILE;
  271. BEGIN
  272.   Assign (cFile, FileName);
  273.   GetFAttr (cFile, Attr);
  274.   IF (DosError = 0) AND ((Attr AND Directory) <> Directory)
  275.     THEN IsFile := TRUE
  276.     ELSE IsFile := FALSE;
  277. END;
  278.  
  279. FUNCTION FilesExist: BOOLEAN;
  280. VAR
  281.   FE: BOOLEAN;
  282.   NotVLabel: WORD;
  283.   DirInfo: SEARCHREC;
  284. BEGIN
  285.   FE := FALSE;
  286.   NotVLabel := ReadOnly + Hidden + SysFile + Archive + Directory;
  287.   FindFirst ('*.*', NotVLabel, DirInfo);
  288.   WHILE (FE = FALSE) AND (DosError = 0) DO
  289.   BEGIN
  290.     IF (Copy (DirInfo.Name, 1, 1) <> '.') THEN
  291.       FE := TRUE;
  292.     FindNext (DirInfo);
  293.   END;
  294.   FilesExist := FE;
  295. END;
  296.  
  297. FUNCTION GetFilePath (CONST PSTR: PATHSTR; VAR sDir: DIRSTR): PATHSTR;
  298. VAR
  299.   jPath : PATHSTR;  { file path,       }
  300.   jDir  : DIRSTR;   {      directory,  }
  301.   jName : NAMESTR;  {      name,       }
  302.   jExt  : EXTSTR;   {      extension.  }
  303. BEGIN
  304.   jPath := PSTR;
  305.   IF jPath = '' THEN jPath := '*.*';
  306.   IF (NOT (jPath [Length (jPath)] IN [':', '\'])) AND IsDir (jPath) THEN
  307.     jPath := jPath + '\';
  308.   IF (jPath [Length (jPath)] IN [':', '\']) THEN
  309.     jPath := jPath + '*.*';
  310.  
  311.   FSplit (FExpand (jPath), jDir, jName, jExt);
  312.   jPath := jDir + jName+ jExt;
  313.  
  314.   sDir := jDir;
  315.   GetFilePath := jPath;
  316. END;
  317.  
  318. FUNCTION VerifyPath (tPath: STR128): STR128;
  319. VAR
  320.   ArcPath, NewPath: STR128;
  321. BEGIN
  322.   ArcPath := Trim (CommandProg (tPath));  { Verify tPath }
  323.   IF (Pos ('.', ArcPath) <= 0) THEN  { if no extension, try COM/EXE }
  324.   BEGIN
  325.     NewPath := FSearch (ArcPath+'.com', GetEnv ('PATH'));
  326.     IF NewPath = '' THEN
  327.       NewPath := FSearch (ArcPath+'.exe', GetEnv ('PATH'));
  328.   END
  329.   ELSE
  330.     NewPath := FSearch (ArcPath, GetEnv ('PATH'));
  331.   IF (NewPath <> '')
  332.     THEN tPath := FExpand (NewPath) + CommandTail (tPath)
  333.     ELSE tPath := '';
  334.   VerifyPath := tPath;
  335. END;
  336.  
  337. PROCEDURE EraseFile (CONST FileName : PATHSTR);
  338. VAR
  339.   cFile : FILE;
  340. BEGIN
  341.   IF IsFile (FileName) THEN BEGIN
  342.     Assign (cFile, FileName);
  343.     SetFAttr (cFile, 0);
  344.     Erase (cFile); CheckIO;
  345.   END;
  346. END;
  347.  
  348. PROCEDURE EraseAllFiles;
  349. VAR
  350.   JustFiles: WORD;
  351.   DirInfo : SEARCHREC;
  352. BEGIN
  353.   JustFiles := ReadOnly + Hidden + SysFile + Archive;
  354.   FindFirst ('*.*', JustFiles, DirInfo);
  355.   WHILE DosError = 0 DO
  356.   BEGIN
  357.     EraseFile (DirInfo.Name);
  358.     FindNext (DirInfo);
  359.   END;
  360. END;
  361.  
  362. PROCEDURE RemoveSubDirs; { Remove remnant subdirectories after processing. }
  363. VAR
  364.   DirInfo: SEARCHREC;
  365. BEGIN
  366.   FindFirst ('*.*', Directory, DirInfo);
  367.   WHILE DosError = 0 DO
  368.   BEGIN
  369.     IF IsDir (DirInfo.Name) AND (Copy (DirInfo.Name, 1, 1) <> '.') THEN
  370.     BEGIN
  371.       ChDir (DirInfo.Name); CheckIO;
  372.       RemoveSubDirs;         { Continue recursion to any sub dirs. }
  373.       EraseAllFiles;         { Now make sure current dir is empty. }
  374.       ChDir ('..');          { Step back to parent directory,      } CheckIO;
  375.       RmDir (DirInfo.Name); { and remove the directory we were in.} CheckIO;
  376.     END;
  377.     FindNext (DirInfo);
  378.   END;
  379. END;
  380.  
  381. PROCEDURE CheckExitCode (CONST eCommand: STR128);
  382. BEGIN
  383.   IF (HeapMan.DosExitCode <> 0) THEN
  384.   BEGIN
  385.     NewLine;
  386.     WriteStr (#7+'*** WARNING! ***  Compressor returned an error code!');
  387.     WriteStr ('FACT is setting QUIET mode OFF, and WATCH mode ON.');
  388.     NewLine;
  389.     WriteStr ('The command which preceded the compressor error was:');
  390.     NewLine;
  391.     WriteStr (eCommand);
  392.     NewLine;
  393.     WriteStr ('Advice: Unless you really need to fix something, let FACT continue.  Wait for');
  394.     WriteStr ('FACT to finish and clean up after itself before you deal with this situation.');
  395.     NewLine;
  396.     QUIET := FALSE;
  397.     WATCH := TRUE;
  398.     Pause;
  399.   END;
  400. END;
  401.  
  402. PROCEDURE StuffKeyBuffer (tKey: CHAR);
  403. BEGIN
  404.   ASM
  405.     mov ah,05h
  406.     mov ch,1
  407.     mov cl, tKey
  408.     int 16h
  409.   END;
  410. END;
  411.  
  412. PROCEDURE cRun (eCommand: STRING);
  413.   FUNCTION WhereX: BYTE; ASSEMBLER; {SWAG routine}
  414.   ASM
  415.     MOV AH, 3     {Ask For current cursor position}
  416.     MOV BH, 0     { On page 0 }
  417.     Int 10h       { Return inFormation in DX }
  418.     Inc DL        { Bios Assumes Zero-based. Crt.WhereX Uses 1 based }
  419.     MOV AL, DL    { Return X position in AL For use in Byte Result }
  420.   END;
  421.  
  422.   FUNCTION WhereY: BYTE; ASSEMBLER; {SWAG routine}
  423.   ASM
  424.     MOV AH, 3    {Ask For current cursor position}
  425.     MOV BH, 0    { On page 0 }
  426.     Int 10h      { Return inFormation in DX }
  427.     Inc DH       { Bios Assumes Zero-based. Crt.WhereY Uses 1 based }
  428.     MOV AL, DH   { Return Y position in AL For use in Byte Result }
  429.   END;
  430.  
  431.   PROCEDURE GotoXY (X, Y: BYTE); ASSEMBLER; {SWAG routine}
  432.   ASM
  433.     MOV DH, Y    { DH = Row (Y) }
  434.     MOV DL, X    { DL = Column (X) }
  435.     Dec DH       { Adjust For Zero-based Bios routines }
  436.     Dec DL       { Turbo Crt.GotoXY is 1-based }
  437.     MOV BH, 0    { Display page 0 }
  438.     MOV AH, 2    { Call For SET CURSOR POSITION }
  439.     Int 10h
  440.   END;
  441.  
  442.   PROCEDURE WriteCharAtCursor (X: CHAR); {SWAG routine}
  443.   VAR
  444.     reg: REGISTERS;
  445.   BEGIN
  446.     reg. AH := $0A;
  447.     reg. AL := Ord (X);
  448.     reg. BH := $00;    {* Display Page Number. * for Graphics Modes! *}
  449.     reg. CX := 1;      {* Word for number of characters to write *}
  450.     Intr ($10, reg);
  451.   END;
  452.  
  453.   PROCEDURE ClrEol; {DDA's routine}
  454.   VAR
  455.     NumCol: WORD ABSOLUTE $0040: $004A; { Number of CRT columns (1-based) }
  456.     X, Y, DistanceToRight: BYTE;
  457.   BEGIN
  458.     X := WhereX;
  459.     Y := WhereY;
  460.     DistanceToRight := NumCol - X;
  461.     Write ('': DistanceToRight);
  462.     WriteCharAtCursor (#32);
  463.     GotoXY (X, Y);
  464.   END;
  465.  
  466. VAR
  467.   X, Y: BYTE;
  468.   Prog: PATHSTR;
  469. BEGIN
  470.   IF QUIET THEN
  471.   BEGIN
  472.     eCommand := eCommand + '>nul';
  473.     X := WhereX;
  474.     Y := WhereY;
  475.     Write ('Shelled out, running ', CommandProg (eCommand));
  476.   END;
  477.  
  478.   Prog := Upper (getFileName (CommandProg (eCommand)));
  479.  
  480.   IF Prog = 'AIN' THEN StuffKeyBuffer (#8);
  481.  
  482.   { If you change the following to Borland's DOS.Exec, }
  483.   { don't forget to add "SwapVectors" before and after. }
  484.   DosError := Heapman.Execute (ComSpec, ' /c ' + eCommand);
  485.  
  486.   IF QUIET THEN
  487.   BEGIN
  488.     GotoXY (X, Y);
  489.     ClrEol;
  490.   END;
  491. END;
  492.  
  493. PROCEDURE Inform (info: STRING);
  494. BEGIN
  495.   NewLine;
  496.   WriteLn ('Level ', RecursionLevel, '; executing following command line:');
  497.   WriteStr (info);
  498.   Pause;
  499. END;
  500.  
  501. PROCEDURE RenameArchive (fName: PATHSTR; fExt: EXTSTR);
  502. VAR
  503.   f: FILE;
  504. BEGIN
  505.   Assign (f, fName + fExt);
  506.   Rename (f, fName + '.-' + Copy (fExt, 3, 2));
  507.   IF WATCH THEN
  508.   BEGIN
  509.     WriteStr ('Archive '+fName+fExt+' is being renamed to avoid destruction.');
  510.     WriteStr ('It has been renamed to '+fName + '.-' + Copy (fExt, 3, 2));
  511.     Pause;
  512.   END;
  513. END;
  514.  
  515. (*
  516. FUNCTION CheckAuthenticity (fName: PATHSTR; fExt: EXTSTR): BOOLEAN;
  517. VAR
  518.   AV: BOOLEAN;
  519.   f: FILE;
  520.   c: CHAR;
  521. BEGIN
  522.   AV := FALSE;
  523.  
  524.   IF IsFile (fName+fExt) THEN
  525.   BEGIN
  526.     IF fExt = '.ARJ' THEN
  527.     BEGIN
  528.       cRun ('arj a -he1 '+fName+fExt+' nul');
  529.       IF (HeapMan.DosExitCode = 4) THEN
  530.         AV := TRUE;
  531.     END
  532.     ELSE
  533.     IF fExt = '.ZIP' THEN
  534.     BEGIN
  535.       Assign (f, fName);
  536.       Reset (f, 1);
  537.       Seek (f, 7); { Snarl... This isn't it, but I thought it was. }
  538.       BlockRead (f, c, 1);
  539.       Close (f);
  540.       IF ((Ord (c) SHR 1) AND 1) = 1 THEN
  541.         AV := TRUE;
  542.     END;
  543.   END;
  544.   CheckAuthenticity := AV;
  545. END;
  546. *)
  547.  
  548. PROCEDURE SetFileTime (fName: PATHSTR; ArcTime: LONGINT);
  549. VAR
  550.   Arc: FILE;
  551. BEGIN
  552.   IF IsFile (fName) THEN
  553.   BEGIN
  554.     Assign (Arc, fName);
  555.     Reset (Arc);
  556.     SetFTime (Arc, ArcTime);
  557.     Close (Arc);
  558.   END;
  559. END;
  560.  
  561. PROCEDURE GetLatestFTime (VAR LatestFTime: LONGINT);
  562. VAR
  563.   FileInfo: SEARCHREC;
  564. BEGIN
  565.   FindFirst ('*.*', AnyFile, FileInfo);
  566.   WHILE DosError = 0 DO
  567.   BEGIN
  568.     IF IsDir (FileInfo.Name) AND (Copy (FileInfo.Name, 1, 1) <> '.')
  569.       THEN BEGIN
  570.         ChDir (FileInfo.Name);
  571.         GetLatestFTime (LatestFTime);  { RECURSION! }
  572.         ChDir ('..');
  573.       END
  574.       ELSE
  575.         IF IsFile (FileInfo.Name) AND (FileInfo.Time > LatestFTime) THEN
  576.           LatestFTime := FileInfo.Time;
  577.     FindNext (FileInfo);
  578.   END;
  579. END;
  580.  
  581. FUNCTION FindLatestFTime: LONGINT;
  582. VAR
  583.   LatestFTime: LONGINT;
  584. BEGIN
  585.   LatestFTime := 0;
  586.   GetLatestFTime (LatestFTime);
  587.   FindLatestFTime := LatestFTime;
  588. END;
  589.  
  590. PROCEDURE RunCommandLine (fInfo: SEARCHREC; ReCompress: STR128);
  591. VAR
  592.   ArcTime: LONGINT;
  593.   aPos: BYTE;
  594.   fn,
  595.   ReCompressT: STRING;
  596.   e: STRING[5];
  597.   f: FILE;
  598.  
  599. BEGIN
  600.   ArcTime := FindLatestFTime;
  601.  
  602.   IF NewExt = '.ZIP' THEN
  603.   BEGIN
  604.     IF (RecursionLevel > 1)
  605.       THEN e := ' -e0 '   { STORING *nested* ZIP files }
  606.       ELSE e := ' -ex ';  { yields smaller ZIPs overall }
  607.   END
  608.   ELSE e := #32;
  609.  
  610.   fn := getFileName (fInfo.Name) + NewExt;
  611.  
  612.   aPos := Pos ('%A', Upper (ReCompress));
  613.   IF (aPos > 0) THEN
  614.   BEGIN
  615.     ReCompressT := ReCompress;
  616.     Delete (ReCompressT, aPos, 2);
  617.     Insert (fn, ReCompressT, aPos);
  618.   END
  619.   ELSE
  620.     ReCompressT := ReCompress + e + fn + #32 + '*.*';
  621.  
  622.   IF WATCH THEN Inform (ReCompressT);
  623.   cRun (ReCompressT);
  624.  
  625.   SetFileTime (fn, ArcTime);
  626.  
  627.   Assign (f, fn);
  628.   Rename (f, '..\' + fn);  { Move new archive to parent directory }
  629.  
  630.   IF NewExt <> '.JRC' THEN CheckExitCode (ReCompressT);
  631.  
  632.   RemoveSubDirs;
  633.   EraseAllFiles;
  634.   ChDir ('..'); CheckIO;
  635.   IF IsDir (fInfo.Name) THEN RmDir (fInfo.Name); CheckIO;
  636. END;
  637.  
  638. PROCEDURE CompressDirs (ReCompress: STR128);
  639. { "Preserve" subdirectories by archiving individually. }
  640. VAR
  641.   FileInfo: SEARCHREC;
  642.  
  643. BEGIN
  644.   FindFirst ('*.*', Directory, FileInfo);
  645.   WHILE DosError = 0 DO
  646.   BEGIN
  647.     IF IsDir (FileInfo.Name) AND (Copy (FileInfo.Name, 1, 1) <> '.') THEN
  648.     BEGIN
  649.       ChDir (FileInfo.Name); CheckIO;
  650.       CompressDirs (ReCompress);
  651.  
  652.       RunCommandLine (FileInfo, ReCompress);
  653.     END;
  654.     FindNext (FileInfo);
  655.   END;
  656. END;
  657.  
  658. PROCEDURE ReCompressThem (DirName, ReCompress: STR128; DirsCompressed: BOOLEAN);
  659. VAR
  660.   FileInfo: SEARCHREC;
  661.   ArcTime: LONGINT;
  662.   ReCompressT: STR128;
  663.   fn: STR128;
  664.  
  665. BEGIN
  666.   FindFirst (DirName, Directory, FileInfo);
  667.   WHILE DosError = 0 DO
  668.   BEGIN
  669.     IF IsDir (FileInfo.Name) AND (Copy (FileInfo.Name, 1, 1) <> '.') THEN
  670.     BEGIN
  671.       fn := FExpand (getFileName (FileInfo.Name));
  672.  
  673.       ChDir (FileInfo.Name); CheckIO;
  674.       EraseFile (fn + NewExt);  { Erase old version of this }
  675.  
  676.    { ┌───────────────────────────────────────────────────────────┐ }
  677.    { │ Convert any extracted subdirs to individual archives.     │ }
  678.    { │                                                           │ }
  679.    { │ } IF NOT DirsCompressed THEN CompressDirs (ReCompress); { │ }
  680.    { │                                                           │ }
  681.    { │ ONLY for compressors which don't preserve subdirectories! │ }
  682.    { └───────────────────────────────────────────────────────────┘ }
  683.  
  684.       RunCommandLine (FileInfo, ReCompress);
  685.  
  686.       FindNext (FileInfo);
  687.     END;
  688.   END;
  689.   Dec (RecursionLevel);
  690. END;
  691.  
  692. PROCEDURE DeCompressThem (ArcName, ReCompress: STR128; DirsCompressed: BOOLEAN);
  693. CONST
  694.   DirExt = '.└┬┘';
  695. VAR
  696.   FileInfo: SEARCHREC;
  697.   fn,
  698.   DeCompressT: STR128;
  699.   FileID: EXTSTR;
  700.   aPos,
  701.   ArcPos: BYTE;
  702.   ftc: STRING[30]; { Files To Compress }
  703.   Changed: BOOLEAN; { Have we changed the directory already? }
  704.  
  705.   Y, M, D, W : WORD;
  706.   h1, h2, m1, m2, s1, s2, o1, o2: WORD;
  707.  
  708.   aName: PATHSTR;
  709.   fExt: EXTSTR;
  710.   CmdLine: STR128;
  711.  
  712. BEGIN
  713.   Inc (RecursionLevel);
  714.   IF RecursionLevel = 1 THEN
  715.   BEGIN
  716.     ClrScr;
  717.     WriteStr ('~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~');
  718.     WriteStr ('Starting conversion of:  ' + FExpand (ArcName));
  719.     WriteStr ('Converting to extension: ' + NewExt);
  720.     IF WATCH
  721.       THEN Pause
  722.       ELSE NewLine;
  723.   END;
  724.   FindFirst (ArcName, AnyFile, FileInfo);
  725.   WHILE DosError = 0 DO
  726.   BEGIN
  727.     IF (NOT ONE) AND IsDir (FileInfo.Name) THEN {Check for archives in subdirs}
  728.     BEGIN
  729.       IF (Copy (FileInfo.Name, 1, 1) <> '.') THEN
  730.       BEGIN
  731.         ChDir (FileInfo.Name); CheckIO;
  732.         DeCompressThem ('*.*', ReCompress, DirsCompressed);
  733.           { Recursively cycle through subdirectories. }
  734.         ChDir ('..'); CheckIO;
  735.       END
  736.     END
  737.     ELSE BEGIN { If we have an actual file, continue. }
  738.       fn := FExpand (getFileName (FileInfo.Name));
  739.       FileID := Upper (getFileExt (FileInfo.Name));
  740.       ArcPos := Pos (FileID+'.', ArcString);
  741.  
  742.       IF (FileID <> '') AND (ArcPos > 0) THEN  { ELSE = Skip non-archives }
  743.       BEGIN
  744.         IF IsDir (fn + DirExt) THEN  { Skip duplicates of archives. }
  745.         BEGIN
  746.           IF FileID = NewExt THEN
  747.             ReNameArchive (fn, FileID);
  748.         END
  749.         ELSE
  750.         BEGIN
  751.           aName := FExpand (FileInfo.Name);
  752.  
  753.           DeCompressT := ArcArray[ArcPos].DeCompress;
  754.           aPos := Pos ('%A', Upper (DeCompressT));
  755.           IF (aPos > 0) THEN
  756.           BEGIN
  757.             Delete (DeCompressT, aPos, 2);
  758.             Insert (aName, DeCompressT, aPos);
  759.           END
  760.           ELSE
  761.             DeCompressT := DeCompressT + #32 + aName + ' *.*';
  762.  
  763.           IF WATCH THEN Inform (DeCompressT);
  764.  
  765.           GetDate (Y, M, D, W);
  766.           SetDate (1980, 1, 1);  { Set all directory dates to Jan. 1st, 1980 }
  767.           MkDir (fn + DirExt); CheckIO;
  768.           ChDir (fn + DirExt); CheckIO;
  769.  
  770.           GetTime (h1, m1, s1, o1);
  771.  
  772.           cRun (DeCompressT);
  773.  
  774.           SetDate (Y, M, D);
  775.           GetTime (h2, m2, s2, o2);  { Adjust date if we just passed midnight. }
  776.           IF (h2 < h1) THEN
  777.           BEGIN
  778.             m2 := m2 + ((s2 + 1) div 60);
  779.             s2 := (s2 + 1) mod 60;
  780.  
  781.             SetTime (23, 59, 59, 30);
  782.             IF NOT QUIET THEN
  783.               WriteStr ('Adjusting for midnight ...');
  784.             Delay (900);
  785.             SetTime (h2, m2, s2, o2);
  786.           END;
  787.  
  788.           Changed := FALSE;
  789.           IF FilesExist THEN
  790.           BEGIN { Erase archives only if decompressed and not wanted. }
  791.             IF FileID <> '.JRC' THEN
  792.               CheckExitCode (DeCompressT);
  793.  
  794.             IF (RecursionLevel > 1) THEN
  795.               EraseFile ('..\' + FileInfo.Name)
  796.             ELSE
  797.             IF (RecursionLevel = 1) AND DelOriginal THEN
  798.               BEGIN
  799.                 CmdLine := Upper (STRING (Ptr (PrefixSeg, $0080)^));
  800.                 fExt := Upper (getFileExt (ArcName));
  801.                 IF (Length (fExt) > 0) AND (NOT (Pos (#32+fExt, CmdLine) > 0)) THEN
  802.                   FileList^.DelWhenDone := TRUE;
  803.               END;
  804.  
  805.             IF NOT ONE THEN
  806.               DeCompressThem ('*.*', ReCompress, DirsCompressed);
  807.                   { Check for nested archives }
  808.           END
  809.           ELSE BEGIN
  810.             Changed := TRUE;
  811.             ChDir ('..'); CheckIO;
  812.             RmDir (fn + DirExt); CheckIO;
  813.           END;
  814.           IF NOT Changed THEN
  815.           BEGIN
  816.             ChDir ('..'); CheckIO;
  817.           END;
  818.         END;
  819.       END;
  820.     END;
  821.     FindNext (FileInfo);  { Continue for any more specified archives }
  822.   END;
  823.   ReCompressThem ('*' + DirExt, ReCompress, DirsCompressed);
  824.     { Clean up decompressed files }
  825. END;
  826.  
  827. PROCEDURE DisplayCompressorList;
  828. VAR
  829.   number,
  830.   Index, I2: BYTE;
  831. BEGIN
  832.   number := 0;
  833.   Index := 1;
  834.   WHILE (Index < (Length (ArcString) - 1)) AND WATCH DO
  835.   BEGIN
  836.     IF ArcString [Index] = '.' THEN
  837.     BEGIN
  838.       I2 := Index;
  839.       Inc (number);
  840.       Write ('#', number, ': extension is ');
  841.       REPEAT
  842.         Inc (Index);
  843.         Write (ArcString [Index]);
  844.       UNTIL ArcString [Index+1] = '.';
  845.       NewLine;
  846.       WriteStr ('ReCompression command line: ' + ArcArray [I2].ReCompress);
  847.       WriteStr ('DeCompression command line: ' + ArcArray [I2].DeCompress);
  848.       WriteLn ('Subdirectories compressed: ', ArcArray [I2].DirsCompressed);
  849.       Pause;
  850.     END;
  851.     Inc (Index);
  852.   END;
  853. END;
  854.  
  855. PROCEDURE BuildCompressorList;
  856. LABEL
  857.   NextArc;
  858. VAR
  859.   IniPath : PATHSTR; {IniPath, etc fully qualified pathnames of *.Ini files}
  860.   IniDir  : DIRSTR;
  861.   IniName : NAMESTR;
  862.   IniExt  : EXTSTR;
  863.   IniFile: TEXT;
  864.   IniLine,
  865.   IniVar: PATHSTR;
  866.  
  867.   ArcPos,
  868.   EqualPos: BYTE;
  869.   Prefix: STRING[2];
  870.   Command, DrComp,
  871.   DeComp, ReComp: STR128;
  872.   DONE: BOOLEAN;
  873.  
  874. BEGIN
  875.   FSplit (FExpand (ParamStr(0)), IniDir, IniName, IniExt); { break up path }
  876.   IniPath := IniDir + IniName + '.INI';
  877.   ArcString := '';
  878.  
  879.   IF NOT IsFile (IniPath) THEN { MUST HAVE a .INI file, no defaults. }
  880.     Halt (1)
  881.   ELSE
  882.   BEGIN
  883.     NewLine;
  884.     WriteStr ('Validating compressors defined in FACT.INI: ');
  885.  
  886.     Assign (IniFile, IniPath);
  887.     Reset (IniFile); CheckIO;
  888.     WHILE NOT SeekEoF (IniFile) DO { Find compressor definitions. }
  889.     BEGIN
  890.       ReadLn (IniFile, IniLine);
  891.       IF (Length (IniLine) > 4) AND (IniLine [1] <> ';')
  892.         AND (Upper (Copy (IniLine, 1, 4)) = 'EXT=') THEN
  893.       BEGIN
  894.         IniVar := Trim (Upper (Copy (IniLine, 5, Length (IniLine) - 4)));
  895.         DeComp := ''; ReComp := ''; DrComp := '';
  896.         DONE := SeekEof (IniFile);
  897.  
  898.         WHILE NOT DONE DO  { Compile extensions, plus compressor data. }
  899.         BEGIN
  900.           ReadLn (IniFile, IniLine);
  901.           IF SeekEoF (IniFile) THEN DONE := TRUE;
  902.           EqualPos := Pos ('=', IniLine);
  903.           IF (EqualPos > 0) THEN
  904.             Command := Copy (IniLine, EqualPos+1, Length (IniLine)-EqualPos);
  905.             Prefix := Upper (Copy (IniLine, 1, 2));
  906.             IF (Prefix = 'DE') THEN DeComp := Command ELSE
  907.             IF (Prefix = 'RE') THEN ReComp := Command ELSE
  908.             IF (Prefix = 'DC') THEN DrComp := Command ELSE
  909.               GOTO NextArc; { Abort definition if anything unexpected appears.}
  910.             IF (DeComp <> '') AND (ReComp <> '') AND (DrComp <> '')
  911.               THEN DONE := TRUE;
  912.         END;
  913.  
  914.         IF (DeComp <> '') AND (ReComp <> '') THEN  { Now validate definition. }
  915.         BEGIN
  916.           DeComp := VerifyPath (DeComp);
  917.           ReComp := VerifyPath (ReComp);
  918.  
  919.           IF (DeComp <> '') AND (ReComp <> '') THEN
  920.           BEGIN  {Add validated data to array.}
  921.             IF (IniVar = 'LZS') AND QUIET THEN
  922.             BEGIN
  923.               ReComp := ReComp + ' /m';
  924.               DeComp := DeComp + ' /m';
  925.             END;
  926.             IF (IniVar = 'LZH') AND QUIET THEN
  927.             BEGIN
  928.               IF NOT (Pos (ReComp, 'n2') > 0) THEN ReComp := ReComp + ' -n2';
  929.               IF NOT (Pos (DeComp, 'n2') > 0) THEN DeComp := DeComp + ' -n2';
  930.             END;
  931.             ArcPos := 1+Length (ArcString);
  932.             ArcArray [ArcPos].ReCompress := ReComp;
  933.             ArcArray [ArcPos].DeCompress := DeComp;
  934.             ArcArray [ArcPos].DirsCompressed :=
  935.               (Length (DrComp) > 0) AND (Upcase (DrComp[1]) = 'Y');
  936.             ArcString := ArcString + '.' + IniVar;
  937.             Write (' .' + RPad (IniVar, 3));
  938.           END;
  939.         END;
  940.       END;
  941.       NextArc:
  942.     END; { loop back to read another line }
  943.     Close (IniFile);
  944.     NewLine; NewLine;
  945.   END;
  946.   IF ArcString <> '' THEN ArcString := ArcString + '.';
  947.   IF WATCH THEN DisplayCompressorList;
  948. END;
  949.  
  950. PROCEDURE BuildFileList (fPath: PATHSTR);
  951. VAR
  952.   nFiles: WORD;
  953.   OneArc: SEARCHREC;
  954.   Anchor, TempNode: FList;
  955.   s: STRING[2];
  956.  
  957. BEGIN
  958.   nFiles := 0;
  959.   Anchor := NIL;
  960.   FileList := NIL;
  961.  
  962.   FindFirst (fPath, Archive, OneArc);
  963.   WHILE DosError = 0 DO  { Add to linked list }
  964.   BEGIN
  965.     IF (Pos (NewExt+'.', ArcString) > 0) THEN {If Arc type is defined properly}
  966.     BEGIN
  967.       Inc (nFiles);
  968.       New (TempNode);
  969.       TempNode^.ArcFName := OneArc.Name;
  970.       TempNode^.DelWhenDone := FALSE;
  971.       TempNode^.Next := NIL;
  972.  
  973.       IF FileList <> NIL
  974.         THEN FileList^.Next := TempNode
  975.         ELSE Anchor := TempNode;
  976.       FileList := TempNode;
  977.     END;
  978.     FindNext (OneArc);
  979.   END;
  980.   FileList := Anchor;
  981.  
  982.   IF (nFiles = 0) THEN Halt (2);
  983.   IF (nFiles <> 1) THEN s := 'es' ELSE s := 'e';
  984.   WriteLn ('Found ', nFiles, ' fil'+s+' which may be converted.');
  985.   NewLine;
  986.   IF WATCH THEN
  987.   BEGIN
  988.     WriteLn ('RAM leftover for compressors: ', MemAvail);
  989.     Pause;
  990.   END;
  991. END;
  992.  
  993. PROCEDURE ProcessFiles;
  994. { Traverse linked list, processing each file. }
  995. VAR
  996.   TempNode: FList;
  997.   pNum: BYTE;
  998.   ArcPos: BYTE;
  999.   ReCompress: STR128;    { Command line being used to compress archives. }
  1000.   DirsCompressed: BOOLEAN; { Does this compressor archive subdirectories? }
  1001.   fExt: EXTSTR;
  1002.  
  1003.   nArchives,
  1004.   nFiles: WORD;
  1005.   s1, s2: STRING[2];
  1006.  
  1007. BEGIN
  1008.   nFiles := 0;
  1009.   nArchives := 0;
  1010.  
  1011.   WHILE FileList <> NIL DO BEGIN
  1012.     Inc (nArchives);
  1013.     FOR pNum := 2 TO ParamCount DO { Convert spec. archives to all others. }
  1014.     BEGIN
  1015.       fExt := getFileExt (FileList^.ArcFName);
  1016.       IF (fExt <> '') AND (Pos (fExt+'.', ArcString) > 0) THEN
  1017.       BEGIN
  1018.         NewExt := Upper (ParamStr (pNum));
  1019.         ArcPos := Pos (NewExt+'.', ArcString);
  1020.         IF (NewExt <> '') AND (ArcPos > 0) THEN { Only convert TO those defined.}
  1021.         WITH FileList^ DO BEGIN
  1022.           Inc (nFiles);
  1023.           ReCompress := ArcArray[ArcPos].ReCompress;
  1024.           DirsCompressed := ArcArray[ArcPos].DirsCompressed;
  1025.           RecursionLevel := 0;
  1026.           DeCompressThem (ArcFName, ReCompress, DirsCompressed);
  1027.         END;
  1028.       END;
  1029.     END;
  1030.     IF FileList^.DelWhenDone THEN
  1031.       EraseFile (FileList^.ArcFName);
  1032.     TempNode := FileList;
  1033.     FileList := FileList^. Next; { Clean up after ourselves. }
  1034.     Dispose (TempNode);
  1035.   END;
  1036.  
  1037.   IF (nFiles = 0) THEN Halt (3);
  1038.  
  1039.   IF nArchives <> 1 THEN s1 := 'es' ELSE s1 := 'e';
  1040.   IF nFiles <> 1 THEN s2 := 'ns' ELSE s2 := 'n';
  1041.  
  1042.   NewLine;
  1043.   WriteLn ('Considered ', nArchives, ' fil'+s1+', and attempted ', nFiles, ' conversio'+s2+'.');
  1044. END;
  1045.  
  1046. PROCEDURE AnalyzeCommandLine;
  1047. BEGIN
  1048.   IF (ParamCount < 2) THEN Halt (255);
  1049.   ComSpec := GetEnv ('COMSPEC');
  1050.   IF ComSpec = '' THEN Halt (6);
  1051.  
  1052.   DelOriginal := IsSwitch ('d');   { Original archive deleted?     }
  1053.   QUIET := IsSwitch ('q');         { Compressor output suppressed? }
  1054.   WATCH := IsSwitch ('w');         { Pause after info messages?    }
  1055.   ONE := IsSwitch ('1');           { Only convert primary archive? }
  1056.  
  1057.   IF WATCH THEN BEGIN
  1058.     NewLine;
  1059.     WriteLn ('DEL=', DelOriginal, ' QUIET=', QUIET, ' WATCH=', WATCH, ' ONE=', ONE);
  1060.     Pause;
  1061.   END;
  1062. END;
  1063.  
  1064. VAR
  1065.   StartDir, fDir: DIRSTR;
  1066.  
  1067. BEGIN
  1068.   SavedExitProc := ExitProc;
  1069.   ExitProc := @CustomExit;  { Insert custom exit procedure. }
  1070.  
  1071.   AnalyzeCommandLine;       { Set global variables. }
  1072.  
  1073.   BuildCompressorList;      { Build compressor definition list. }
  1074.   BuildFileList (GetFilePath (ParamStr (1), fDir));   { Build list of files. }
  1075.  
  1076.   GetDir (0, StartDir);     { Save starting directory. }
  1077.   ChDir (Copy (fDir,1,Length(fDir)-1));     { Change to dir where files are. }
  1078.  
  1079.   ProcessFiles;             { Traverse linked list, processing each archive. }
  1080.  
  1081.   ChDir (StartDir);         { Restore starting directory. }
  1082. END.
  1083.